Shareware Grab Bag/Shareware Grab Bag.iso/050/madtrb17.arc/TREK.P

Text File | 1985-09-08 | 15.5 KB | 657 lines

{$B-}
{$I-}
{$C-}
{$K-}

(*
::::::::::
TREK.TEXT
::::::::::
*)

(*$I-*)
(*$R-*)
program startrek;
label 10;

const
    skill = 2;
    maxscroll= 40;
    maxlines = 22;
    opefficiency = 75;
    maxuni = 32;         (* limits size of array *)
    solarlim = 22;       (* limits placement of characters *)
    pi = 3.14159;
    maxlist = 'n';

type
    space = packed record
    pts, ch: char;
    strength: integer
    end;
    attack = (fired, chanced);
    what   = (pass, go);
    system = (computer, phasers, longscan, shortscan, torpedos, warp, impulse);
    unirange = -maxuni..maxuni;
    galaxy  = array [unirange,unirange] of space;
    string80 = string[80];

var
    msginfo:  array [1..7] of integer;
    universe:  galaxy;
    systems:  array [system] of integer;
    list: array ['a'..'n'] of space;
    names: array[0..18] of string80;
    nomove, seeall, longer, confuse, syshields,
    points, allshields, maxpower, totalpower, currx, curry, level, nmbrbases,
    highest, totalkling, nmbrkling, nmbrtorps,
    shields:  integer;
    currlst: char;
    xdock, ydock:  unirange;
    captain, str, condition:  string80;
    stardate, deadline, direction, seed:  real;
    partdone, alldone, return, babble, baseattacked, hasone:  boolean;
    paddingforsave : packed array[0..73] of char;        { 37 blocks }

    g:  file;
    linesprinted, scrollinfo : integer;
    restored: boolean;

    regs : record
       ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
       end;
    screen : packed array[0..23,0..79] of char;
    blanks : packed array[0..90] of char;
    more : string80;
    viscursor : boolean;

function readreal : real; forward;

function readint : integer; forward;

procedure addln(str: string80); forward;

procedure addscroll(str:string80); forward;

procedure clearscroll; forward;

procedure clrmesg; forward;

procedure condcheck(x,y: integer; var red : boolean);  forward;

procedure disable (shot: integer); forward;

procedure initscroll; forward;

procedure mesg( line:integer; st:string80); forward;

procedure moveround(var initlx,initly: integer); forward;

procedure numstr(realnum:real; leng, decimal: integer); forward;

function ok(checkx, checky: integer): boolean; forward;

function rand(lolim, hilim: integer): integer; forward;

procedure sector(x,y: integer; var result : integer); forward;

procedure scroll; forward;

procedure scrollup(up,down,left,right: integer); forward;

procedure short(x,y: integer); forward;

procedure printch(x,y : integer; ch : char); forward;

procedure togglecursor; forward;


{$I TREK_INI.P }

{$I TREK_OBJ.P }

{$I TREK_PLY.P }

{ these are global procedures }

function pwroften(n:integer):integer;
begin
case n of
    0 : pwroften := 1;
    1 : pwroften := 10;
    2 : pwroften := 100;
    3 : pwroften := 1000;
    4 : pwroften := 10000;
    end;
end;

function readreal {: real};
const nodot = 42;
var inc,dot,i,divisor,number,count,sign : integer;
    ch : char;
    buffer : char;
begin
    gotoxy(57,15); write('     '); gotoxy(57,15);
    togglecursor;
    dot := nodot; count := 0; sign := 1; number := 0;
    repeat
    read(kbd,buffer);
    ch := buffer;
    if ch = chr(8) then
        if count > 0 then begin
        if count = dot then dot := nodot
        else number := number div 10;
        count := count - 1;
        gotoxy(wherex-1, wherey); write(' ');
        gotoxy(wherex-1, wherey);
        end
        else if sign = -1 then begin
        sign := 1;
        gotoxy(wherex-1, wherey); write(' ');
        gotoxy(wherex-1, wherey);
        end
        else begin
        sound(480); delay(300); sound(1320); delay(200); nosound;
        end
    else if (ch = '-') and (count = 0) and (sign = 1) then begin
        sign := -1; write(buffer)
    end
    else if (count <  5) then
        if (ch = '.') and (dot = nodot) then begin
        count := count + 1;
        dot := count;
        write(buffer)
        end
        else if ch in ['0'..'9'] then begin
        inc := ord(ch) - ord('0');
        if maxint - (number * 10) >= inc then begin
            count := count + 1;
            number := number * 10 + inc;
            write(buffer)
        end
        end
    until ch = chr(13);
    if (dot = nodot) or (count - dot = 0) then
    divisor := 1
    else
    divisor := trunc(pwroften(count - dot));
    readreal := (number/divisor) * sign;
    togglecursor
end;


function readint {: integer};
var inc,number,count,sign : integer;
    ch : char;
    buffer : char;
begin
    gotoxy(57,14); write('      '); gotoxy(57,15);
    togglecursor;
    count := 0; sign := 1; number := 0;
    repeat
    read(kbd,buffer);
    ch := buffer;
    if ch = chr(8) then
        if count > 0 then begin
        number := number div 10;
        count := count - 1;
        gotoxy(wherex-1, wherey); write(' ');
        gotoxy(wherex-1, wherey);
        end
        else if sign = -1 then begin
        sign := 1;
        gotoxy(wherex-1, wherey); write(' ');
        gotoxy(wherex-1, wherey);
        end
        else begin
        sound(480); delay(300); sound(1320); delay(200); nosound;
        end
    else if (ch = '-') and (count = 0) and (sign = 1) then begin
        sign := -1; write(buffer)
    end
    else if (count < 5) and (ch in ['0'..'9']) then begin
        inc := ord(ch) - ord('0');
        if maxint - (number * 10) >= inc then begin
        count := count + 1;
        number := number * 10 + inc;
        write(buffer)
        end
    end
    until ch = chr(13);
    readint := number * sign;
    togglecursor
end;

procedure addln{str: string};
var
   oldscroll,
   x,l    : integer;
begin
     oldscroll := scrollinfo;
     l := length(str);
     scrollinfo := scrollinfo + l;
     if scrollinfo > maxscroll then begin
     l := l - scrollinfo + maxscroll;
     scrollinfo := maxscroll
     end;
     gotoxy(oldscroll+1,linesprinted+1);
     str := str + '    ';
     move(str[1],screen[linesprinted,oldscroll],l);
     for x := 1 to l do write(str[x]);
end;

procedure clearscroll;
var i : integer;
begin
     for i := 0 to linesprinted do begin
     gotoxy(1,i+1);
     write('                                         ');
     move(blanks,screen[i],maxscroll+1)
     end;
     scrollinfo:= 0;
     linesprinted:= 0;
end;

procedure scroll;
var
    i: integer;
    temp: char;
begin
    if linesprinted = maxlines then begin
    gotoxy(1,24);
    write(more);
    read(kbd,temp);
    while not (temp in [' ',chr(4),'d',chr(13)]) do begin
        write(chr(7));
        read(kbd,temp);
    end;
    gotoxy(1,24);
    write('            ');
    if temp = chr(13) then begin
        linesprinted:= 21;
        scrollup(0,maxlines,0,maxscroll)
    end
    else if temp = ' ' then
       clearscroll
    else begin
        for i := maxlines downto 12 do
        scrollup(0,i,0,maxscroll);
        linesprinted:= 11;
    end
    end;
    linesprinted:= linesprinted + 1;
    scrollinfo:= 0;
end;

procedure addscroll{str:string};
begin
     addln(str);
     scroll
end;

procedure initscroll;
var i : integer;
begin
     for i := 0 to maxlines do
     move(blanks,screen[i],maxscroll);
     scrollinfo:= 0;
     linesprinted:= 0;
end;

procedure numstr{realnum:real; leng, decimal: integer};
var
    count, i, int: integer;
    sample: string80;
begin
    sample:= '0123456789.';
    str:= '';
    for i:= 1 to decimal do
    realnum:= realnum * 10;
    int:= round(realnum);
    if decimal <> 0 then leng:= leng - 1;
    for i:= 1 to leng do begin
    str:= concat(copy(sample,abs(int mod 10) + 1,1),str);
    if i = decimal then str := concat(copy(sample,11,1),str);
    int:= int div 10
    end;
    count:= 1;
    while (str[count] = '0') and (length(str) > count) do  begin
    str[count]:= ' ';
    count:= count + 1
    end;
    if realnum < 0 then
    str[1]:= '-'
end;

procedure mesg{line:integer; st:string};
var
    i: integer;
begin
    for i:= 1 to length(st) do
    printch(52+i,line+15,st[i]);
    msginfo[line]:= length(st)
end;

procedure clrmesg;
var
    i, j: integer;
begin
    for i:= 1 to 7 do begin
    for j:= 1 to msginfo[i] do
        printch(52+j,i+15,' ');
    msginfo[i]:= 0
    end;
end;

function rand {lolim, hilim: integer): integer};
begin
    seed:= seed*27.1368+31.468;
    seed:=seed-trunc(seed);
    if lolim > hilim then
    rand:= lolim
    else
    rand:= trunc(seed*(hilim-lolim+1)+lolim)
end;

function ok{checkx, checky: integer): boolean};
begin
    ok := (abs(checkx)<=maxuni) and (abs(checky)<=maxuni)
end;

procedure disable {shot: integer};
var
    origeffect, effected: system;
begin
    if syshields < 0 then  begin
       case rand(1,7) of
        1:  effected:= longscan;
        2:  effected:= shortscan;
        3:  effected:= phasers;
        4:  effected:= torpedos;
        5:  effected:= computer;
        6:  effected:= warp;
        7:  effected:= impulse
    end;
    origeffect:= effected;
    repeat
        if systems[effected] = 0 then
        if effected <> impulse then
            effected:= succ(effected)
        else
            effected:= longscan
    until (systems[effected] <> 0) or (effected = origeffect);
    systems[effected]:= systems[effected] - round(shot/6);
    if systems[effected] < 0 then systems[effected]:= 0
    end
end;

procedure moveround{var initlx,initly: integer};
label 10;
var
   x,y,counter:  integer;
begin
    for counter:=0 to maxuni do
    for x:= -counter to counter do
        for y:= -counter to counter do
        if ok(x+initlx,y+initly) then
            if universe[initlx+x, initly+y].ch=' ' then begin
            initlx:=x+initlx;
            initly:=y+initly;
            goto 10
            end;
10: end;

procedure togglecursor;
begin
    viscursor := not viscursor;
end;

{ .PROC TREKINTRINSICS recoded from terak assembly }

function onscreen (x,y : integer) : char;
begin
    onscreen := screen[y,x]
end;

procedure printch {x,y : integer; ch : char};
begin
    gotoxy(x+1,y+1); write(ch);
    screen[y,x] := ch;
end;

procedure short {x,y : integer};
var
    lim2,nx,ny,xscrn,yscrn : integer;
    ch : char;
    subscreen : packed array[0..10,0..20] of char;
begin
    lim2 := maxuni + 8;
    xscrn := 0;
    for nx := x - 10 to x + 10 do begin
    yscrn := 10;
    for ny := y - 5 to y + 5 do begin
        if (yscrn = 5) and (xscrn = 10) then
        ch := '@'
        else if (abs(nx) > lim2) or (abs(ny) > lim2) then
        ch := '$'
        else if (abs(nx) > maxuni) or (abs(ny) > maxuni) then
        ch := ' '
        else begin
        ch := universe[nx,ny].ch;
        if ch = 'A' then begin if seeall < 0 then
            ch := universe[nx,ny].pts end
        else if ch = 'R' then begin
            if seeall < 0 then
            ch := ' '
        end
        else if ch in ['/','%','B'] then
            if nmbrkling >= 5 then
            ch := ' '
        end;
        subscreen[yscrn,xscrn] := ch;
        yscrn := yscrn - 1
    end;
    xscrn  := xscrn + 1
    end;
    for ny := 10 downto 0 do begin
    gotoxy(43,ny+1); write(subscreen[ny])
    end
end;

procedure condcheck {x,y : integer; var red : boolean};
var nx,ny : integer;
begin
    babble := false;
    red := false;
    for nx := x - 10 to x + 10 do
    for ny := y - 5 to y + 5 do
        if (abs(nx) <= maxuni) and (abs(ny) <= maxuni) then
        if universe[nx,ny].ch = 'T' then begin
            babble := true; red := true
        end
        else if universe[nx,ny].ch in ['A','O','R','H','X','+'] then
            red := true
end;

procedure sector {x,y : integer; var result : integer};
var
    ch : char;
    nx,ny,
    klingons,
    bases,
    stars,
    others : integer;
begin
    klingons := 0;
    bases := 0;
    stars := 0;
    others := 0;
    for nx := x - 10 to x + 10 do
    for ny := y - 5 to y + 5 do
        if (abs(nx) <= maxuni) and (abs(ny) <= maxuni) then begin
        ch := universe[nx,ny].ch;
        if ch = '+' then
            klingons := klingons + 1
        else if ch = '#' then
            bases := bases + 1
        else if ch = '*' then
            stars := stars + 1
        else if (ch <> ' ') and (ch <> '@') then
            others := others + 1
        end;
    if others > 9 then
    others := 9;
    if stars > 9 then
    stars := 9;
    if bases > 9 then
    bases := 9;
    if klingons > 9 then
    klingons := 9;
    result := (((((others * 10) + stars) * 10) + bases) * 10) + klingons
end;

procedure scrollup {up,down,left,right : integer};
var
    xdx,ydx,lngth : integer;
begin
    lngth := right - left;
    for ydx := up to down - 1 do
    move(screen[ydx + 1,left],screen[ydx,left],lngth);
    move(blanks,screen[down,left],lngth);
    for ydx := up to down do begin
    gotoxy(left+1,ydx+1);
    for xdx := left to left + lngth do
        write(screen[ydx,xdx]);
    end
end;

procedure restore;
var
   fname : string80;
   num: integer;
begin
    addln('What file? ');
    togglecursor;
    readln(con,fname);
    togglecursor;
    scrollinfo:= maxscroll;
    assign(g,fname);
    reset(g);
    if ioresult = 0 then begin
    blockread(g,msginfo[1],37*4);
    clearscroll;
    restored:= true;
    close(g);
    erase(g);
    addscroll('Game retrieved. Continue.');
    end
end;

procedure driver;
var
   gstat: integer;
   i : char;
begin
    { calling playgame with  gstat of 6 lets the player move first }
    { calling playgame with gstat of 3 lets the enemy move first }
    { all other gstats are set in playgame to control either:
    a) the ending of the game (0..6)
    b) start a new level      (-1)
    c) calling restore        (-3)
    d) calling one of the object handling routines in group (ord of cmd)
    }
    gstat := 6;
    repeat
    playgame(gstat);
    if gstat = -1 then begin
        clrmesg;
        for i:= 'a' to currlst do
        if list[i].ch = '/' then
            return:= true;
        if return then
        level:= level - 1
        else
        level := level + 1;
        if level > highest then
        highest := level;
        maxpower:= 3000 + points div 10 ;
        if not return or (level <> 0) then begin
        addscroll('       You are entering a');
        if not return then
            addln('       higher')
        else
            addln('       lower');
        addscroll(' level.');
        addscroll(' (Please wait)');
        scroll;
        startgame(-1); { creates  new universe }
        clearscroll
        end
    end
    else if gstat = -3 then
        restore           { either loads a saved game or is NOP }
    else if gstat in [0..7] then
        startgame(gstat)  { isn't going to return }
       else if gstat < 128 then
        group(chr(gstat));
    if gstat < 0 then
        gstat := 6
    else if chr(gstat) in ['D','d','G','g','U','u'] then
        gstat := 3
       else gstat := 6
    until (level = 0) and return
end;

begin (*main*)
    clrscr;
    alldone := false;
    partdone := false;
    fillchar(blanks,88,' ');
    more := '--More --';
    viscursor := true;
    clrscr;
    gotoxy(8,2);
    writeln('   Stardate 2699.9, version II.13');
    writeln;
    writeln;
    writeln('                 Transcript from Starfleet:');
    writeln;
    writeln('            Retrieve the Staff of Surak, which has been stolen');
    writeln('         from its place on Vulcan.   Be wary of aliens.');
    writeln;
    writeln;
    gotoxy(1,15); write('"restore" to resume a saved game');
    gotoxy(1,16); write('"score" to see scores from previous games');
    gotoxy(1,14); write('Enter your name, captain:  '); readln(con,captain);
    if captain = 'score' then
    startgame(8);
    clrscr;
    togglecursor;
    level:= 1;
    startgame(-2);
    if alldone then goto 10;
    restored:= false;
    return:= false;
    clearscroll;
    if captain = 'restore' then
       restore;
    if alldone then goto 10;
    if not restored then begin
    startgame(-1);
    if alldone then goto 10;
    clearscroll;
    addscroll('Your mission is ready to begin.');
    end;
    scroll;
    driver;
    clearscroll;
    addscroll('Congratulations! You have');
    addscroll(' returned from a dangerous');
    addscroll(' mission. For your efforts, ');
    addscroll(' you will receive a lifetime');
    addscroll(' supply of C rations.');
    delay(3000);
    startgame(3);
10: end.